home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / plap.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-07-09  |  12.2 KB  |  362 lines
  1. ;;;-*-Mode: LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. ;;;
  31. ;;; The portable implementation of the LAP assembler.
  32. ;;;
  33. ;;; The portable implementation of the LAP assembler works by translating
  34. ;;; LAP code back into Lisp code and then compiling that Lisp code.  Note
  35. ;;; that this implementation is actually going to get a lot of use.  Some
  36. ;;; implementations (KCL) won't implement a native LAP assembler at all.
  37. ;;; Other implementations may not implement native LAP assemblers for all
  38. ;;; of their ports.  All of this implies that this portable LAP assembler
  39. ;;; needs to generate the best code it possibly can.
  40. ;;; 
  41.  
  42.  
  43. ;;;
  44. ;;; 
  45. ;;;
  46.  
  47. (defmacro lap-case (operand &body cases)
  48.   (once-only (operand)
  49.     `(ecase (car ,operand)
  50.        ,@(mapcar #'(lambda (case)
  51.              `(,(car case)
  52.                (apply #'(lambda ,(cadr case) ,@(cddr case))
  53.                   (cdr ,operand))))
  54.          cases))))
  55.  
  56. (defvar *lap-args*)
  57. (defvar *lap-rest-p*)
  58. (defvar *lap-i-regs*)
  59. (defvar *lap-v-regs*)
  60. (defvar *lap-fv-regs*)
  61. (defvar *lap-t-regs*)
  62.  
  63. (defvar *lap-optimize-declaration* '#.*optimize-speed*)
  64.  
  65.  
  66. (eval-when (load eval)
  67.   (setq *make-lap-closure-generator*
  68.     #'(lambda (closure-var-names arg-names index-regs 
  69.            vector-regs fixnum-vector-regs t-regs lap-code)
  70.         (compile-lambda
  71.           (make-lap-closure-generator-lambda
  72.         closure-var-names arg-names index-regs 
  73.         vector-regs fixnum-vector-regs t-regs lap-code)))
  74.  
  75.     *precompile-lap-closure-generator*
  76.     #'(lambda (cvars args i-regs v-regs fv-regs t-regs lap)
  77.         `(function
  78.            ,(make-lap-closure-generator-lambda cvars args i-regs 
  79.          v-regs fv-regs t-regs lap)))
  80.     *lap-in-lisp*
  81.     #'(lambda (cvars args iregs vregs fvregs tregs lap)
  82.         (declare (ignore cvars args))
  83.         (make-lap-prog
  84.           iregs vregs fvregs tregs 
  85.           (flatten-lap lap ;(opcode :label 'exit-lap-in-lisp)
  86.                )))))
  87.  
  88. (defun make-lap-closure-generator-lambda (cvars args i-regs v-regs fv-regs t-regs lap)
  89.   (let* ((rest (memq '&rest args))
  90.      (ldiff (and rest (ldiff args rest))))
  91.     (when rest (setq args (append ldiff '(&rest .lap-rest-arg.))))
  92.     (let* ((*lap-args* (if rest ldiff args))
  93.        (*lap-rest-p* (not (null rest))))
  94.       `(lambda ,cvars
  95.      #'(lambda ,args
  96.          #-CMU (declare ,*lap-optimize-declaration*)
  97.          #-CMU ,(make-lap-prog-internal i-regs v-regs fv-regs t-regs lap)
  98.          #+CMU
  99.              ;;
  100.              ;; Use LOCALLY instead of a declare on the lambda so that we don't
  101.              ;; suppress arg count checking...
  102.              (locally (declare ,*lap-optimize-declaration*)
  103.            ,(make-lap-prog-internal i-regs v-regs fv-regs t-regs lap)))))))
  104.  
  105. (defun make-lap-prog (i-regs v-regs fv-regs t-regs lap)
  106.   (let* ((*lap-args* 'lap-in-lisp)
  107.      (*lap-rest-p* 'lap-in-lisp))
  108.     (make-lap-prog-internal i-regs v-regs fv-regs t-regs lap)))
  109.  
  110. (defun make-lap-prog-internal (i-regs v-regs fv-regs t-regs lap)
  111.   (let* ((*lap-i-regs* i-regs)
  112.      (*lap-v-regs* v-regs)
  113.      (*lap-fv-regs* fv-regs)
  114.      (*lap-t-regs* t-regs)
  115.      (code (mapcar #'lap-opcode lap)))
  116.     `(prog ,(mapcar #'(lambda (reg)
  117.             `(,(lap-reg reg)
  118.               ,(lap-reg-initial-value-form reg)))
  119.             (append i-regs v-regs fv-regs t-regs))
  120.        (declare (type index ,@(mapcar #'lap-reg *lap-i-regs*))
  121.             (type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*))
  122.             (type #+structure-wrapper cache-number-vector
  123.                   #-structure-wrapper (simple-array fixnum)
  124.                   ,@(mapcar #'lap-reg *lap-fv-regs*))
  125.                 #-cmu ,*lap-optimize-declaration*)
  126.        ,.code)))
  127.  
  128. (defvar *empty-vector* '#())
  129. (defvar *empty-fixnum-vector*
  130.   (make-array 8 :initial-element 0))
  131.  
  132. (defun lap-reg-initial-value-form (reg)
  133.   (cond ((memq reg *lap-i-regs*) 0)
  134.         ((memq reg *lap-v-regs*) '*empty-vector*)
  135.         ((memq reg *lap-fv-regs*) '*empty-fixnum-vector*)
  136.         ((memq reg *lap-t-regs*) nil)
  137.         (t
  138.          (error "What kind of register is ~S?" reg))))
  139.  
  140. (defun lap-opcode (opcode)    
  141.   (lap-case opcode
  142.     (:move (from to)
  143.      `(setf ,(lap-operand to) ,(lap-operand from)))
  144.       
  145.     ((:eq :neq :fix=) (arg1 arg2 label)
  146.      `(when ,(lap-operands (ecase (car opcode)
  147.                  (:eq 'eq) (:neq 'neq) (:fix= 'RUNTIME\ FIX=))
  148.                arg1
  149.                arg2)
  150.     (go ,label)))
  151.  
  152.     ((:izerop) (arg label)
  153.      `(when ,(lap-operands 'RUNTIME\ IZEROP arg)
  154.     (go ,label)))
  155.  
  156.     (:std-instance-p (from label)
  157.      `(when ,(lap-operands 'RUNTIME\ STD-INSTANCE-P from) (go ,label)))
  158.     #+pcl-user-instances
  159.     (:user-instance-p (from label)
  160.      `(when ,(lap-operands 'RUNTIME\ USER-INSTANCE-P from) (go ,label)))
  161.     (:fsc-instance-p (from label)
  162.      `(when ,(lap-operands 'RUNTIME\ FSC-INSTANCE-P from) (go ,label)))
  163.     (:built-in-instance-p (from label)
  164.      (declare (ignore from))
  165.      `(when ,t (go ,label)))                            ;***
  166.     (:structure-instance-p (from label)
  167.      `(when ,(lap-operands 'RUNTIME\ STRUCTURE-INSTANCE-P from) (go ,label)))    ;***
  168.     
  169.     (:jmp (fn)
  170.      (if (eq *lap-args* 'lap-in-lisp)
  171.      (error "Can't do a :JMP in LAP-IN-LISP.")
  172.      `(return
  173.         ,(if *lap-rest-p*
  174.          `(RUNTIME\ APPLY ,(lap-operand fn) ,@*lap-args* .lap-rest-arg.)
  175.          `(RUNTIME\ FUNCALL ,(lap-operand fn) ,@*lap-args*)))))
  176.  
  177.     (:return (value)
  178.      `(return ,(lap-operand value)))
  179.       
  180.     (:label (label) label)
  181.     (:go   (label)  `(go ,label))
  182.  
  183.     (:exit-lap-in-lisp () `(go exit-lap-in-lisp))
  184.     
  185.     (:break ()      `(break))
  186.     (:beep  ()      #+Genera`(zl:beep))
  187.     (:print (val)   (lap-operands 'print val))
  188.     ))
  189.  
  190. (defun lap-operand (operand)
  191.   (lap-case operand
  192.     (:reg (n) (lap-reg n))
  193.     (:cdr (reg) (lap-operands 'cdr reg))
  194.     ((:cvar :arg) (name) name)
  195.     (:constant (c) `',c)
  196.     ((:std-wrapper :fsc-wrapper :built-in-wrapper :structure-wrapper
  197.       :built-in-or-structure-wrapper :std-slots :fsc-slots
  198.       :wrapper-cache-number-vector
  199.       #+pcl-user-instances :user-wrapper
  200.       #+pcl-user-instances :user-slots)
  201.      (x)
  202.      (lap-operands (ecase (car operand)
  203.              (:std-wrapper       'RUNTIME\ STD-WRAPPER)
  204.              (:fsc-wrapper       'RUNTIME\ FSC-WRAPPER)
  205.                      #+pcl-user-instances
  206.              (:user-wrapper      'RUNTIME\ USER-WRAPPER)
  207.              (:built-in-wrapper  'RUNTIME\ BUILT-IN-WRAPPER)
  208.              (:structure-wrapper 'RUNTIME\ STRUCTURE-WRAPPER)
  209.              (:built-in-or-structure-wrapper
  210.                                  'RUNTIME\ BUILT-IN-OR-STRUCTURE-WRAPPER)
  211.              (:std-slots         'RUNTIME\ STD-SLOTS)
  212.              (:fsc-slots         'RUNTIME\ FSC-SLOTS)
  213.                      #+pcl-user-instances
  214.              (:user-slots        'RUNTIME\ USER-SLOTS)
  215.              (:wrapper-cache-number-vector 
  216.               'RUNTIME\ WRAPPER-CACHE-NUMBER-VECTOR))
  217.            x))
  218.     
  219.      
  220.     (:i1+     (index)         (lap-operands 'RUNTIME\ I1+ index))
  221.     (:i+      (index1 index2) (lap-operands 'RUNTIME\ I+ index1 index2))
  222.     (:i-      (index1 index2) (lap-operands 'RUNTIME\ I- index1 index2))
  223.     (:ilogand (index1 index2) (lap-operands 'RUNTIME\ ILOGAND index1 index2))
  224.     (:ilogxor (index1 index2) (lap-operands 'RUNTIME\ ILOGXOR index1 index2))
  225.     
  226.     (:iref    (vector index)       (lap-operands 'RUNTIME\ IREF vector index))
  227.     (:iset    (vector index value) (lap-operands 'RUNTIME\ ISET vector index value))
  228.  
  229.     (:cref   (vector i)       `(RUNTIME\ SVREF ,(lap-operand vector) ,i))
  230.     (:lisp-variable (symbol) symbol)
  231.     (:lisp          (form)   form)
  232.     ))
  233.  
  234. (defun lap-operands (fn &rest regs)
  235.   (cons fn (mapcar #'lap-operand regs)))
  236.  
  237. (defun lap-reg (n) (intern (format nil "REG~D" n) *the-pcl-package*))
  238.  
  239.  
  240. ;;;
  241. ;;; Runtime Implementations of the operands and opcodes.
  242. ;;;
  243. ;;; In those ports of PCL which choose not to completely re-implement the
  244. ;;; LAP code generator, it may still be provident to consider reimplementing
  245. ;;; one or more of these to get the compiler to produce better code.  That
  246. ;;; is why they are split out.
  247. ;;; 
  248. (proclaim '(declaration pcl-fast-call))
  249.  
  250. (defmacro RUNTIME\ FUNCALL (fn &rest args)
  251.   `(method-function-funcall ,fn ,.args))
  252.  
  253. (defmacro RUNTIME\ APPLY (fn &rest args)
  254.   `(method-function-apply ,fn ,.args))
  255.  
  256. (defmacro RUNTIME\ STD-WRAPPER (x)
  257.   `(std-instance-wrapper ,x))
  258.  
  259. (defmacro RUNTIME\ FSC-WRAPPER (x)
  260.   `(fsc-instance-wrapper ,x))
  261.  
  262. #+pcl-user-instances
  263. (defmacro RUNTIME\ USER-WRAPPER (x)
  264.   `(get-user-instance-wrapper ,x))
  265.  
  266. (defmacro RUNTIME\ BUILT-IN-WRAPPER (x)
  267.   `(built-in-wrapper-of ,x))
  268.  
  269. (defmacro RUNTIME\ STRUCTURE-WRAPPER (x)
  270.   `(built-in-or-structure-wrapper ,x))
  271.  
  272. (defmacro RUNTIME\ BUILT-IN-OR-STRUCTURE-WRAPPER (x)
  273.   `(built-in-or-structure-wrapper ,x))
  274.  
  275. (defmacro RUNTIME\ STRUCTURE-INSTANCE-P (x)
  276.   `(structure-instance-p ,x))
  277.  
  278. (defmacro RUNTIME\ STD-SLOTS (x)
  279.   `(std-instance-slots (the std-instance ,x)))
  280.  
  281. (defmacro RUNTIME\ FSC-SLOTS (x)
  282.   `(fsc-instance-slots ,x))
  283.  
  284. #+pcl-user-instances
  285. (defmacro RUNTIME\ USER-SLOTS (x)
  286.   `(get-user-instance-slots ,x))
  287.  
  288. (defmacro RUNTIME\ WRAPPER-CACHE-NUMBER-VECTOR (x)
  289.   `(wrapper-cache-number-vector ,x))
  290.  
  291. (defmacro RUNTIME\ STD-INSTANCE-P (x)
  292.   `(std-instance-p ,x))
  293.  
  294. (defmacro RUNTIME\ FSC-INSTANCE-P (x)
  295.   `(fsc-instance-p ,x))
  296.  
  297. #+pcl-user-instances
  298. (defmacro RUNTIME\ USER-INSTANCE-P (x)
  299.   `(get-user-instance-p ,x))
  300.  
  301. (defmacro RUNTIME\ IZEROP (x)
  302.   `(zerop (the index ,x)))
  303.  
  304. (defmacro RUNTIME\ FIX= (x y)
  305.   `(= (the index ,x) (the index ,y)))
  306.  
  307. ;;;
  308. ;;; These are the implementations of the index operands.  The portable
  309. ;;; assembler generates Lisp code that uses these macros.  Even though
  310. ;;; the variables holding the arguments and results have type declarations
  311. ;;; on them, we put type declarations in here.
  312. ;;;
  313. ;;; Some compilers are so stupid...
  314. ;;;
  315. (defmacro RUNTIME\ IREF (vector index)
  316.   `(svref (the simple-vector ,vector) (the index ,index)))
  317.  
  318. (defmacro RUNTIME\ ISET (vector index value)
  319.   `(setf (svref (the simple-vector ,vector) (the index ,index)) ,value))
  320.  
  321. (defmacro RUNTIME\ SVREF (vector index)
  322.   `(svref (the simple-vector ,vector) (the index ,index)))
  323.  
  324. (defmacro RUNTIME\ I+ (index1 index2)
  325.   `(the index (+ (the index ,index1) (the index ,index2))))
  326.  
  327. (defmacro RUNTIME\ I- (index1 index2)  
  328.   `(the index (- (the index ,index1) (the index ,index2))))
  329.  
  330. (defmacro RUNTIME\ I1+ (index)
  331.   `(the index (1+ (the index ,index))))
  332.  
  333. (defmacro RUNTIME\ ILOGAND (index1 index2)
  334.   #-Lucid `(the index (logand (the index ,index1) (the index ,index2)))
  335.   #+Lucid `(%logand ,index1 ,index2))
  336.  
  337. (defmacro RUNTIME\ ILOGXOR (index1 index2)
  338.   `(the index (logxor (the index ,index1) (the index ,index2))))
  339.  
  340. ;;;
  341. ;;; In the portable implementation, indexes are just fixnums.
  342. ;;; 
  343.  
  344. (defconstant index-value-limit most-positive-fixnum)
  345.  
  346. (defun index-value->index (index-value) index-value)
  347. (defun index->index-value (index) index)
  348.  
  349. (defun make-index-mask (cache-size line-size)
  350.   (declare (type index cache-size line-size))
  351.   (let ((cache-size-in-bits (floor (log cache-size 2)))
  352.     (line-size-in-bits (floor (log line-size 2)))
  353.     (mask 0))
  354.     (declare (type index cache-size-in-bits line-size-in-bits mask))
  355.     (dotimes (i cache-size-in-bits)
  356.       (setq mask (the index (dpb 1 (byte 1 i) mask))))
  357.     (dotimes (i line-size-in-bits)
  358.       (setq mask (the index (dpb 0 (byte 1 i) mask))))
  359.     mask))
  360.  
  361.  
  362.